home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / f2c / may_5_92.lha / f2c.VMay_5_1992 / libI77 / lwrite.c < prev    next >
C/C++ Source or Header  |  1992-05-07  |  3KB  |  191 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "lio.h"
  5. int L_len;
  6.  
  7. t_putc(c)
  8. {
  9.     recpos++;
  10.     putc(c,cf);
  11.     return(0);
  12. }
  13. lwrt_I(n) ftnint n;
  14. {
  15.     char buf[LINTW],*p;
  16. #ifdef USE_STRLEN
  17.     (void) sprintf(buf," %ld",(long)n);
  18.     if(recpos+strlen(buf)>=L_len)
  19. #else
  20.     if(recpos + sprintf(buf," %ld",(long)n) >= L_len)
  21. #endif
  22.         (*donewrec)();
  23.     for(p=buf;*p;PUT(*p++));
  24. }
  25. lwrt_L(n, len) ftnint n; ftnlen len;
  26. {
  27.     if(recpos+LLOGW>=L_len)
  28.         (*donewrec)();
  29.     (void) wrt_L((Uint *)&n,LLOGW, len);
  30. }
  31. lwrt_A(p,len) char *p; ftnlen len;
  32. {
  33.     int i;
  34.     if(recpos+len>=L_len)
  35.         (*donewrec)();
  36.     if (!recpos)
  37.         { PUT(' '); ++recpos; }
  38.     for(i=0;i<len;i++) PUT(*p++);
  39. }
  40.  
  41.  static int
  42. l_g(buf, n) char *buf; double n;
  43. {
  44. #ifdef Old_list_output
  45.     doublereal absn;
  46.     char *fmt;
  47.  
  48.     absn = n;
  49.     if (absn < 0)
  50.         absn = -absn;
  51.     fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
  52. #ifdef USE_STRLEN
  53.     sprintf(buf, fmt, n);
  54.     return strlen(buf);
  55. #else
  56.     return sprintf(buf, fmt, n);
  57. #endif
  58.  
  59. #else
  60.     register char *b, c, c1;
  61.  
  62.     b = buf;
  63.     *b++ = ' ';
  64.     if (n < 0) {
  65.         *b++ = '-';
  66.         n = -n;
  67.         }
  68.     else
  69.         *b++ = ' ';
  70.     if (n == 0) {
  71.         *b++ = '0';
  72.         *b++ = '.';
  73.         *b = 0;
  74.         goto ret;
  75.         }
  76.     sprintf(b, LGFMT, n);
  77.     if (*b == '0') {
  78.         while(b[0] = b[1])
  79.             b++;
  80.         }
  81.     /* Fortran 77 insists on having a decimal point... */
  82.     else for(;; b++)
  83.         switch(*b) {
  84.             case 0:
  85.                 *b++ = '.';
  86.                 *b = 0;
  87.                 goto ret;
  88.             case '.':
  89.                 while(*++b);
  90.                 goto ret;
  91.             case 'E':
  92.                 for(c1 = '.', c = 'E';  *b = c1;
  93.                     c1 = c, c = *++b);
  94.                 goto ret;
  95.             }
  96.  ret:
  97.     return b - buf;
  98. #endif
  99.     }
  100.  
  101.  static void
  102. l_put(s) register char *s;
  103. {
  104.     register int c, (*pn)() = putn;
  105.     while(c = *s++)
  106.         (*pn)(c);
  107.     }
  108.  
  109. lwrt_F(n) double n;
  110. {
  111.     char buf[LEFBL];
  112.  
  113.     if(recpos + l_g(buf,n) >= L_len)
  114.         (*donewrec)();
  115.     l_put(buf);
  116. }
  117. lwrt_C(a,b) double a,b;
  118. {
  119.     char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
  120.     int al, bl;
  121.  
  122.     al = l_g(bufa, a);
  123.     for(ba = bufa; *ba == ' '; ba++)
  124.         --al;
  125.     bl = l_g(bufb, b) + 1;    /* intentionally high by 1 */
  126.     for(bb = bufb; *bb == ' '; bb++)
  127.         --bl;
  128.     if(recpos + al + bl + 3 >= L_len && recpos)
  129.         (*donewrec)();
  130.     PUT(' ');
  131.     PUT('(');
  132.     l_put(ba);
  133.     PUT(',');
  134.     if (recpos + bl >= L_len) {
  135.         (*donewrec)();
  136.         PUT(' ');
  137.         }
  138.     l_put(bb);
  139.     PUT(')');
  140. }
  141. l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  142. {
  143. #define Ptr ((flex *)ptr)
  144.     int i;
  145.     ftnint x;
  146.     double y,z;
  147.     real *xx;
  148.     doublereal *yy;
  149.     for(i=0;i< *number; i++)
  150.     {
  151.         switch((int)type)
  152.         {
  153.         default: fatal(204,"unknown type in lio");
  154.         case TYSHORT:
  155.             x=Ptr->flshort;
  156.             goto xint;
  157.         case TYLONG:
  158.             x=Ptr->flint;
  159.         xint:    lwrt_I(x);
  160.             break;
  161.         case TYREAL:
  162.             y=Ptr->flreal;
  163.             goto xfloat;
  164.         case TYDREAL:
  165.             y=Ptr->fldouble;
  166.         xfloat: lwrt_F(y);
  167.             break;
  168.         case TYCOMPLEX:
  169.             xx= &Ptr->flreal;
  170.             y = *xx++;
  171.             z = *xx;
  172.             goto xcomplex;
  173.         case TYDCOMPLEX:
  174.             yy = &Ptr->fldouble;
  175.             y= *yy++;
  176.             z = *yy;
  177.         xcomplex:
  178.             lwrt_C(y,z);
  179.             break;
  180.         case TYLOGICAL:
  181.             lwrt_L(Ptr->flint, len);
  182.             break;
  183.         case TYCHAR:
  184.             lwrt_A(ptr,len);
  185.             break;
  186.         }
  187.         ptr += len;
  188.     }
  189.     return(0);
  190. }
  191.